home *** CD-ROM | disk | FTP | other *** search
Text File | 1998-05-21 | 22.0 KB | 1,190 lines |
- ;; Some tests for edebug.
-
- ;;=======================
- ;; Reading tests.
-
- (testing (one two) three)
-
- (progn '(testing))
-
- (a . (b . c))
-
- (a . "test")
-
- (a . (b . nil))
-
- (a . [one two three])
-
- ;;===========================
- ;; Backquote test
-
- (defun test ()
- (macroexpand '(` ((, (a)) . (, test))))
- )
- (test)
-
- (progn (` ((, (point)) . (, (point)))))
- (` (, (point)))
-
- (defun test ()
- (message "%d" 999999)
-
- (defun test1 ()
-
- (progn
- (defun test ()
- (message "%d" 99999))
- (test)
- )
-
- )
- (test1)
- (test)
-
- (eval (edebug-` (append [(, (point)) (, (point))] nil)))
- (eval (edebug-` (append (, (point)) (, (point)) nil)))
-
- (eval (progn (edebug-` (edebug-` (, '(, (point)))))))
-
- (eval (edebug-` (let (((, 'a) 'b))
- (message "%s" a))))
-
- (defun test ()
-
- (let ((r '(union x y)))
- (` (` (foo (, '(, r))))))
- )
-
- (defun test ()
- (let ((a '(one two))) a))
-
- (def-edebug-spec test-func (sexp &rest def-form))
-
- (setq edebug-unwrap-results t)
- (setq edebug-unwrap-results nil)
-
- (defmacro test-func (func &rest args)
- (edebug-` ((, func) (,@ args))))
-
- (test-func message (concat "hi%s" "there") (+ 1 2))
-
- (defmacro test-progn (&rest body)
- (edebug-` (progn (,@ body))))
-
- (def-edebug-spec test-progn (&rest def-form))
-
- (test-progn
- (message "testing"))
-
-
- ;;=================
- ;; Testing read syntax.
-
- (format "testing %s %s %s" 1 2 (+ 1 2))
-
- (defun test-syntax ()
- (setq mode-line-stuff'("draft(%b) ^C^S(end) ^C^Q(uit) ^C^K(ill)"))
- ;; (re-search-forward "[.?!][])""']*$" nil t)
- ;; (let (test)
- )
- )
-
- (test-syntax)
-
- (let ())
- ;;====================
- ;; Testing function
-
- (defun foo (x)
- (mapconcat (function identity) x ", "))
-
- (defun foo (x)
- (mapconcat 'identity x ", "))
-
- (defun foo (x)
- (mapconcat (function (lambda (x) x)) x ", "))
-
- (require 'cl)
-
- (defun foo (x)
- (mapconcat (function* (lambda (x &optional (y (1+ x)) &key xyz) x)) x ", "))
-
- (defun foo (x)
- (mapconcat '(lambda (x) x) x ", "))
-
- (foo '(1 2 3))
-
- (apply 'identity one two)
-
- (defun test1 (arg)
- arg)
-
- (def-edebug-spec test1
- (form))
- (setq x 5)
- (test1 (+ x 2))
-
- (("test1" test1)))
-
- (def-edebug-spec test1
- (&define sexp form))
-
- (test (test1 xyz (message "jfdjfd")))
-
- ;;====================
- ;; Anonymous function test
- (defun hej (arg)
- "docstring"
- (interactive (list 2))
- ((lambda (luttr &rest params)
- (apply luttr luttr params))
- (function (lambda (self n)
- (edebug-trace "n: %s" n)
- (if (= n 5) (edebug nil "n is 5"))
- (edebug-tracing "cond"
- (cond
- ((= 0 n) 1)
- (t (* n (funcall self self (1- n))))))))
- 11))
-
- (defun hej-test ()
- (interactive)
- (message
- "testing")
- (hej edebug-execution-mode)
- )
- (hej-test)
-
- (defun lambda-test ()
- ((lambda (arg) arg) 'xyz))
- (lambda-test)
-
- (defun test ()
- "doc string
- (with left paren on start of line)"
-
- 1)
-
-
- (progn
- (save-window-excursion
- (split-window)
- (split-window)
- (setq w (next-window)))
- (edebug-window-live-p w))
-
-
- ;;====================
- ;; Test edebugging top-level-forms
-
- (def-edebug-spec test nil)
- (let ((arg (list 'a 'b 'c)))
- (defun test (arg)
- arg)
- (test arg))
-
-
- (fset 'emacs-setq (symbol-function 'setq))
-
- (defmacro my-setq (&rest args)
- (while args
- (set (car args) (eval (car (cdr args))))
- (setq args (cdr (cdr args)))))
-
- (defmacro test-macro (&rest args)
- (cons 'list args))
- (def-edebug-spec test-macro 0)
-
- (defun test ()
- (test-macro (message "testing")))
- (test)
-
- (defun test ()
- (message "someting")
- (function (lambda ()
- (message "something else")))
- )
-
- (funcall (test))
-
- ;;====================
- ;; Test for and inc
- (def-edebug-spec for
- (symbolp ["from" def-form ["to" def-form] ["do" &rest def-form]]))
-
- ;; (symbolp ['from form ['to form] ['do &rest form]])
-
- (inc x)
- (defmacro inc (var)
- (list 'setq var (list '1+ var)))
-
- (defmacro for (var from init to final do &rest body)
- (let ((tempvar (make-symbol "max")))
- (edebug-` (let (((, var) (, init))
- ((, tempvar) (, final)))
- (while (<= (, var) (, tempvar))
- (,@ body)
- (inc (, var)))))))
-
- (defun test-for (one two)
- (for i from one to two do
- (message "%s" i))
- )
-
- (let ((n 5))
- (for i from n to (* n (+ n 1)) do
- (message "%s" i)))
-
- (test-for 3 10)
-
- ;;====================
- ;; Test condition-case
- (def-edebug-spec condition-case
- (symbolp
- form
- &rest (symbolp &optional form)))
-
- (setq edebug-on-signal '(error))
-
- (defun test-condition-case ()
- (condition-case err
- (signal 'error '(oh))
- (error (message "error: %s" err))
- ))
- (test-condition-case)
-
- (require 'cl)
-
- ;;=============
- ;; lexical let
-
- (defun test-lexical ()
- (funcall (lexical-let ((xyz 123))
- (function (lambda (arg) (+ arg xyz))))
- 456))
- (test-lexical)
-
- ;;====================
- ;; case test.
- (defun test-case (one)
- (case one
- ((one) (message "(one)"))
- ("one" (message "one"))
- ('one (message "'one"))
- ))
-
- (test-case 'one)
-
- ;;====================
- ;; Test of do from cl.el
-
- (defun list-reverse (list)
- (do ((x list (cdr x))
- (y nil (cons (car x) y)))
- ((endp x) y)
- (message "x: %s y: %s" x y)
- ))
-
-
- (list-reverse '(testing one two three))
-
- (defmacro test-backquote (arg list)
- (edebug-`
- (progn
- (message "%s %s" (, arg) (, list))
- (mapcar (function (lambda (arg1)
- (message "%s %s" arg1 (, arg)))) (, list)))))
-
- (def-edebug-spec test-backquote (def-form def-form))
- (test-backquote (symbol-name 'something) (list 1 2 3))
-
-
- (defmacro dired-map-over-marks (body arg &optional show-progress)
- (edebug-` (prog1
- (let (buffer-read-only case-fold-search found results)
- (if (, arg)
- (if (integerp (, arg))
- (progn;; no save-excursion, want to move point.
- (dired-repeat-over-lines
- (, arg)
- (function (lambda ()
- (if (, show-progress) (sit-for 0))
- (setq results (cons (, body) results)))))
- (if (< (, arg) 0)
- (nreverse results)
- results))
- ;; non-nil, non-integer ARG means use current file:
- (list (, body)))
- (let ((regexp (dired-marker-regexp)) next-position)
- (save-excursion
- (goto-char (point-min))
- ;; remember position of next marked file before BODY
- ;; can insert lines before the just found file,
- ;; confusing us by finding the same marked file again
- ;; and again and...
- (setq next-position (and (re-search-forward regexp nil t)
- (point-marker))
- found (not (null next-position)))
- (while next-position
- (goto-char next-position)
- (if (, show-progress) (sit-for 0))
- (setq results (cons (, body) results))
- ;; move after last match
- (goto-char next-position)
- (forward-line 1)
- (set-marker next-position nil)
- (setq next-position (and (re-search-forward regexp nil t)
- (point-marker)))))
- (if found
- results
- (list (, body))))))
- ;; save-excursion loses, again
- (dired-move-to-filename))))
-
-
- (def-edebug-spec dired-map-over-marks (&rest def-form))
-
- (dired-map-over-marks
- (message "here") (+ 1 2) t)
-
- ;;====================
- ;; circular structure test
-
- (edebug-install-custom-print)
- (edebug-uninstall-custom-print)
-
- (setq a '(1 2))
- (progn
- (edebug-install-custom-print)
- (setq a '(1 2))
- (setcar a a))
-
- (defun test ()
- (with-custom-print
- (format "%s" (setcar a a)))))
- (test)
- (setcdr a a)
- (let ((b a)) b)
-
- (with-custom-print
- (let ((print-circle t)
- (circ-list (list 'a 'b (vector 1 2 3 4) 'd 'e 'f)))
- (setcar (nthcdr 3 circ-list) circ-list)
- (aset (nth 2 circ-list) 2 circ-list)
- (prin1-to-string circ-list)))
-
- ;;====================
- ;; interactive-p test
- (defun test-interactive ()
- (interactive)
- (interactive-p))
-
- (test-interactive)
- (call-interactively 'test-interactive)
-
-
- ;;====================
- ;; test several things:
- ;; - nested defun.
- ;; - display scrolling.
-
-
- (defmacro testmacro ()
- '(interactive-p))
-
- (call-interactively 'testing1)
- (testing1 9)
-
- (defun testing1 (arg)
- (interactive (list 3))
- (message "%s" (interactive-p)) (sit-for 2)
- (edebug-trace "interactive: %s" (testmacro))
- (defun testing1-1 ()
- (testing1 2))
- ;; (custom-message "%s" arg "extra")
- (current-buffer)
- (selected-window)
- (while (< 0 (setq arg (1- arg)))
- arg
- arg
- arg
- arg
- arg
- arg
- arg
- arg
- arg ; middle
- arg
- arg
- arg
- arg
- arg
- arg
- arg
- arg
- arg
- arg ; jump
- arg
- arg
- arg
- arg
- arg
- arg
- arg
- arg
- arg
- arg
- arg
- arg
- arg
- ))
- (edebug-trace-display "*testing*" "one")
- (edebug-tracer "one\n")
-
- (testing1 a)
- (call-interactively 'testing1)
- (testing1 2)
-
- (testing1-1)
-
-
- (defmacro testmacro ()
- (interactive)
- '(one))
-
- (defun testing2 ()
- (let* ((buf (get-buffer-create "testing"))
- (win (get-buffer-window buf)))
- (testing1 1)
- (window-point win)
- (window-point win)
-
- ;; (read-stream-char buf)
- ))
-
- (testing2)
-
-
- (defun testing3 ()
- (save-excursion
- (set-buffer (get-buffer-create "*testing*"))
- (current-buffer)
- (point)
- (forward-char 1)
- ))
- (testing3)
-
-
- ;;====================
- ;; anonymous function test
- (defun testanon (arg)
- (mapcar '(lambda (x) x) arg)
- (mapcar (function (lambda (x) x)) arg)
- (mapcar (function testing3 ) arg)
- )
-
- (testanon '(1 2 3))
-
- ;;====================
- ;; upward funarg test
-
- (defmacro lambda (&rest args)
- "Return the quoted lambda expression."
- (cons 'function (list (cons 'lambda args))))
-
- (lambda (testing) one two)
-
- (defun testanon2 ()
- "return an anoymous function."
- (function (lambda (x) x))
- )
- ;; Emacs 19 has a lambda macro
- (defun testanon2 ()
- "return an anoymous function."
- (lambda (x) x))
- (testanon2)
-
- (setq func
- (testanon2))
- (funcall func 2)
-
- (defun foo ()
- (mapcar #'(lambda (x)
- (message "%S" x))
- (append '(0) '(a b c d e f))))
- (foo)
-
- ;;====================
- ;; downward funarg test
-
- (defun xxx (func)
- (funcall func))
-
- (defun yyy ()
- (xxx (function (lambda () (message "hello")))))
-
- (yyy)
-
- ;; eval this:
- (def-edebug-spec test nil)
- (defun test (func list)
- (dolist (el list)
- (funcall func el)))
-
- ;; edebug this:
- (defun testcall (l)
- (test (function (lambda (x) (print x))) ;; set breakpoints in anon.
- l))
-
- ;; test call:
- (testcall '(a b c))
-
- ;; flet test.
-
- (defun alep-write-history (&rest args)
- (message "alep-write-history( %s )\n"
- args)
- ;; write out header
- '(write-region (format ";;Saved on %s\n" (current-time-string))
- nil buffer-file-name nil 'shut-up)
- ;; dump all not deleted actions
- (flet ((write-solution (sol)
- t)
- (write-action (action)
- (if (a-h-action-deleted action)
- ;; nothing to be done
- t
- (write-region
- (format "(alep-new-history-action %S %S %S)\n"
- (a-h-action-name action)
- (alep-tnowv-string (a-h-action-in-tnowv
- action))
- (a-h-action-timestamp action))
- nil buffer-file-name t 'shut-up)
- (mapc 'write-solution
- (a-h-action-solutions action)))))
- (mapc 'write-action
- history-list))
- t)
- (setq history-list '(1 2 3))
- (alep-write-history)
-
- ;;=========================
-
- (edebug-trace "my stuff")
-
- (defun fac (n)
- (if (= n 0) (edebug))
- ;#6 1 0 =5
- (if (< 0 n)
- ;#5 =
- (* n (fac (1- n)))
- ;# 5 0
- 1))
- ;# 0
-
- (fac 5)
-
-
- ;;====================
- ;; Timing test - how bad is edebug?
-
- (defun looptest (n)
- (let ((i 0))
- (while (< i n) (setq i (1+ i)))))
-
- (looptest 10000)
-
- ;;====================
- ;; eval-depth testing.
-
- (defun test-depth (i)
- (test-depth (1+ i)))
-
- ;; Without edebug i reaches 193, failing on eval depth
- ;; With edebug, i reaches about 57. Better safe than sorry.
- (setq max-lisp-eval-depth 200)
- (test-depth 0)
-
- ;;====================
- ;; specpdl-size testing.
- (defun test-depth2 (i max)
- (let ((test max-specpdl-size)
- (max-lisp-eval-depth (+ 2 max-lisp-eval-depth))
- )
- (test-depth2 (1+ i) max-specpdl-size)))
-
- (let ((max-lisp-eval-depth 300)
- (max-specpdl-size 3))
- (test-depth2 0 max-specpdl-size))
-
- ;;====================
- ;; Buffer testing.
-
- (defun zprint-region-1 (start end switches)
- (let ((name (concat (buffer-name) ""))
- (width tab-width))
- (save-excursion
- (message "Spooling...")
- (let ((oldbuf (current-buffer)))
- (set-buffer (get-buffer-create " *spool temp*"))
- (widen)
- (erase-buffer)
- (insert-buffer-substring oldbuf start end)
- (setq tab-width width)
- (if (/= tab-width 8)
- (untabify (point-min) (point-max)))
- (setq start (point-min) end (point-max)))
- (apply 'call-process-region
- (nconc (list start end zpr-command nil nil nil
- "-h" name switches)))
- (message "Spooling...done")
- )
- )
- )
-
-
-
- (defun quick-hanoi (nrings)
- (with-output-to-temp-buffer "*hanio*"
- (set-buffer "*hanio*")
- (princ (format "Solution to %s ring hanoi problem\n\n" nrings))
- (hanoi0 nrings 'pole-1 'pole-2 'pole-3)))
-
- (defun hanoi0 (n from to work)
- ;; (edebug-set-window-configuration (edebug-current-window-configuration))
- (if (> n 0)
- (progn
- ;; (save-excursion
- ;; (set-buffer "*hanio*")
- ;; (message "Point=%s window-point=%s" (point)
- ;; (window-point (get-buffer-window "*hanio*")))
- ;; (set-window-point (get-buffer-window "*hanio*") (point))
- ;; )
-
- (hanoi0 (1- n) from work to)
- (princ (format "ring %s from %s to %s\n" n from to))
- (hanoi0 (1- n) work to from))))
-
- (quick-hanoi 5)
-
-
- ;;====================
- ;; Error test
-
- (defun error-generating-function ()
- (message "try again?") (sit-for 1)
- (prog1
- (signal 'bogus '("some error" xyz abc))
- (error "debug-on-error: %s edebug-entered: %s edebug-recursion-depth: %s"
- debug-on-error edebug-entered edebug-recursion-depth)))
-
- ;; --><-- point will be left between the two arrows
- (setq debug-on-error nil)
- (setq edebug-on-signal '(bogus))
-
- (testing-function)
- (defun testing-function ()
- (interactive)
- (message "YYY")
- (error-generating-function)
- (message "ZZZ"))
-
-
- (let ((debug-on-error t))
- xyzzyz)
-
- ;;====================
- ;; Quitting with unwind-protect
-
- (defun unwind-test ()
- (prog1
- (unwind-protect
- (unwind-protect
- (message "testing")
- (message "unwinding1"))
- (message "unwinding2")
- (sit-for 1)
- )
- ))
- (unwind-test)
-
- (defmacro save-buffer-points (&rest body)
- (` (let ((buffer-points
- (mapcar (function (lambda (buf)
- (set-buffer buf)
- (cons buf (point))))
- (buffer-list))))
- (unwind-protect
- (progn
- (,@ body))
- (mapcar (function (lambda (buf-point)
- (if (buffer-name (car buf-point))
- (progn
- (set-buffer (car buf-point))
- (goto-char (cdr buf-point))))))
- buffer-points)))))
-
- (defun testing4 ()
- (with-output-to-temp-buffer "*testing*"
- (princ "Line 1\n")
- (save-buffer-points
- (recursive-edit)
- )
- (princ "Line 2\n")
- ))
-
- (testing4)
- test!
-
-
- ;;====================
- ;; edebug-form-specs for Guido Bosch's flavors
-
- (def-edebug-spec defmethod defun) ; same as defun
- (def-edebug-spec defwhopper defun) ; same as defun
-
- ;;======================
- ;; Check syntax errors.
-
- (defun test-too-many-arguments ()
- (mapcar 'test one two))
-
- (mapcar 'not-enough)
-
- (defun test-not-enough-arguments ()
- (mapcar 'test))
-
- (defun test-bad-function ()
- (function))
-
- (defun test-bad-function ()
- (function
- (bad () )))
-
- (defun test-bad-lambda-arguments ()
- (function (lambda "bad" )))
-
- (defun test-bad-defun-arguments "bad"
- (function (lambda "bad" )))
-
- (defun test-bad-defun-arguments (arg "bad") ;; wrong error
- (function (lambda "bad" )))
-
- (defun test-bad-defun-arguments (&optional)
- (function (lambda "bad" )))
-
- (defun test-bad-let-in-lambda ()
- (function (lambda ()
- (let ((something one bad)))))) ;; wrong error
-
- (defun test-bad-interactive ()
- (interactive one bad))
-
- (defun test-bad-defvar ()
- (defvar test-defvar nil [bad]))
-
- (defun test-bad-let1 ()
- (let bad))
-
- (defun test-bad-let2 ()
- (let ((something one bad))))
-
- (defun test-good-let ()
- (let ((a b))))
-
- (defun test-bad-let3 ()
- (let (((bad)))))
-
- (defun test-bad-let4 ()
- (let ("bad")))
-
- (let ((good (list 'one))) good)
-
- (defun test-bad-setq ()
- (setq "bad" ))
-
- (setq good ok
- "bad")
-
- (defun test-bad-cond ()
- (cond "bad"))
-
- (cond ())
-
- (defun test-bad-cond ()
- (cond () [] "bad"))
-
- (defun test-bad-condition-case1 ()
- (condition-case "bad"))
-
- (defun test-bad-condition-case2 ()
- (condition-case err
- nil
- "bad"))
-
- (defun test-bad-condition-case3 ()
- (condition-case err
- (error "messages")
- ;; ()
- ((error quit) (message "%s" err))))
-
-
- (def-edebug-spec do
- ((&rest &or symbolp
- (fence symbolp &optional form form))
- (form body) body))
-
- (defun bad-do (list)
-
- (do ( x
- (x list (cdr x))
- (y nil (cons (car x) y))
- (x list (cdr x) bad)
- "bad"
- )
- ((endp x) y)
- ))
-
- (defun ok ()
- test
- )
-
- (defun "bad" () )
- (defun)
-
- ;;=========================
-
- ;; Test printing.
-
- (defun test-window-buffer-change (arg)
- "testing"
- (interactive arg)
- (save-window-excursion
- (set-window-buffer (selected-window) (get-buffer "*scratch*"))
- (get-buffer-window (current-buffer))))
- (test-window-buffer-change 'test)
-
-
- (defun test-window-buffer-change ()
- (selected-window))
-
- (test-window-buffer-change 1)
-
- arg
-
-
- (def-edebug-spec edebug-forms
- (&rest edebug-form))
-
- (def-edebug-spec edebug-form
- (&or (edebug-function-symbolp edebug-forms)
- (anonymous-function edebug-forms)
- (edebug-macro-symbolp
- sexp)))
-
-
- (defun test-mapatoms () )
-
- (mapatoms (function (lambda (arg)
- (princ
- arg)
- )))
-
-
- (test-mapatoms)
-
- ;; Test embedded &rest
- (def-edebug-spec symbol-list
- ([&rest "a" symbolp] form))
-
- (defun test ()
- (symbol-list a b a (+ c d)))
- (test)
-
- (def-edebug-spec group-alternates-test
- (&or ["foo" "bar"] "baz"))
-
- (group-alternates-test foo bar)
- (group-alternates-test baz )
-
- ;;---------------------
-
- (defun test ()
- (dolist (f (list 1 2))
- (message f)))
-
- (defun test ()
- (dolist (el (list 'a 'b 'c))
- (print el)))
-
-
- ;; (of-type (type (more type)))
-
- (def-edebug-spec test-nil
- (&or symbolp "nil"))
- (test-nil () )
-
- (defun test ()
- ((lambda (arg) arg) two)
- )
-
-
- ;; Dot notation testing
-
- (def-edebug-spec test-dot
- (symbolp . [&or symbolp (stringp)]))
- (test-dot xyz . jk)
- (test-dot xyz "jk")
-
- (def-edebug-spec test-dot
- (&or symbolp (test-dot1)))
-
- (def-edebug-spec test-dot1
- (test-dot2 . test-dot2))
-
- (def-edebug-spec test-dot2
- (symbolp))
-
- (def-edebug-spec test-dot2
- ([&or test-dot1 nil]))
-
- (def-edebug-spec test-dot1
- (symbolp))
-
- (&or symbolp (test-dot)))
-
-
- (defun test ()
- (test-dot (a . b)))
-
- (def-edebug-spec edebug-specs
- (symbolp . symbolp))
-
- (def-edebug-spec edebug-specs1
- (&or symbolp))
-
- (def-edebug-spec edebug-spec
- (&or
- symbolp))
-
-
- (def-edebug-spec test-not
- (symbolp . [¬ symbolp form]))
- (test-not "string")
-
- ;;--------------------------
- ;; Loop macro testing
-
- (defun test ()
- (loop-var (((var1 (var2 var4) . (var3 var5)) . var1))
- ))
-
- (loop-var (var1 var2 . var3))
- (loop-var (var1 ["bad"] . "bad"))
-
- ' (var2 var3 . var4))
-
- (loop for ((a . b) (c . d))
- of-type ((float . float) (integer. integer))
- )
-
- (defun test ()
- (loop if some-test
- collect a-form into var
- else minimize x ;; of-type some-type
- and append x
- end))
-
- (defun test ()
- (loop for x from 1 to 9
- and y = nil then x
- collect (list x y)))
-
- (defun test ()
- (loop for i from 10 downto 1 by 3
- do (print i)))
-
-
- (defun test ()
- (loop for item = 1 then (+ item 10)
- repeat 5
- collect item))
-
- (defun test ()
- (loop for z upfrom 2
- thereis
- (loop for n upfrom 3 below (+ z 2) ;; + was log
- thereis
- (loop for x below z
- thereis
- (loop for y below z
- thereis (= (+ (* x n) ;; * was expt
- (* y n))
- (* z n)))))))
-
- (defun test ()
- (loop for name in '(fred sue alice joe june)
- as age in '(22 26 19 20 10)
- append (list name age) into name-and-age-list
- count name into name-count
- sum age into total-age
- finally
- (return (values (round* total-age name-count)
- name-and-age-list))))
-
- (defun test ()
- (loop for x from 0 to 3
- do (print x)
- if (zerop (mod x 2))
- do (princ " a")
- and if (zerop (floor* x 2))
- do (princ " b")
- end
- and do (princ " c")))
-
-
- (defun test ()
- (loop initially do (message x)
- do (dispatch-event event)))
-
- (defun test ()
- (loop initially do (popup-menu menu) ;; do is an error here.
- with event = (allocate-event)
- do (dispatch-event event)))
-
- (defun popup-menu-synchronously (menu)
- (loop initially (popup-menu menu)
- with event = (allocate-event)
- until (button-release-event-p (next-event event))
- do (dispatch-event event)
- finally do (deallocate-event event)))
-
- (defun test ()
- (loop with list = '(1 2 3 4)
- for item in list
- sum item into summation
- collect (list item)))
-
- ;;----------
-
- (defun test-catch (n)
- (if (> n 0)
- (let* ((test
- (catch 'test
- (test-catch (1- n)))))
- (if test
- (do-throw)))
- (do-throw)))
-
- (defun do-throw ()
- (funcall 'throw 'test 'here))
-
- (test-catch 3)
-
-
- ;;------------
-
- (defun* foo (a &optional b &key c d (e 17)))
-
- (def-edebug-spec test-vector
- ((vector form)))
-
- (defun test ()
-
- (test-vector [one]))
-
- [testing one two three]
- (testing one two three)
-
- (def-edebug-spec test
- (&optional &or ["something" keywordp] symbolp))
-
- (test something :somekey)
-
- ;;----------
-
-
-
- (defun find-faq (filename)
- "Hmtar en faq."
- (interactive
-
- (list
- (all-faq-a-valid-ftp
- (intern-soft
- (let ((minibuffer-help-form
- (function
- (let* ((partial (buffer-string))
- (soft (intern-soft partial all-faq-known-files)))
- (if soft
- (set soft (append (cdr (symbol-value soft))
- (list (car (symbol-value soft))))))
- (if (and soft (all-faq-a-valid-ftp soft))
- (mapconcat
- (function
- (lambda (apair)
- (car apair)))
- (symbol-value soft)
- "\n"))))))
- (completing-read "What faq? "
- all-faq-known-files
- (function all-faq-a-valid-ftp)
- t ""))
- all-faq-known-files)))
- )
- (find-file filename))
-
-
- ;;===============
-
- ;; Keyword testing
-
- (def-edebug-spec test
- (&key (bad "one") (good "thing")))
- (defun test-key ()
- (test :bad one)
- (test1 :bad one))
-
- (def-edebug-spec test
- (("one")))
-
- (&rest ["one" "two"]))
-
- (test (one))
-
- (progn (message "one" ) )
- (testet xxx)
- (progn (message "one" ) )
-
- (let ((a (+ 1 1)))
- (1+ a))
-
- (mapcar 'test (list 1 2 3))
- (defun test (testing) testing)
-
- ;;==================
- ;; Test defstruct.
-
- (defun test ()
- (defstruct
- (test (:constructor construct (args)))
- a
- (b (+ a c))
- c))
-
- ;;================
- ;; advice
-
- (defun foo (x)
- "Add 1 to x."
- (1+ x))
-
- (require 'advice)
-
- (defadvice foo (before add2 first activate)
- " Add 2 to x"
- (setq x (1+ x)))
-
- (foo 3)
-